home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / CARCDR.ASM < prev    next >
Encoding:
Assembly Source File  |  1992-11-21  |  20.0 KB  |  641 lines
  1. ;* CARCDR.ASM
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Borland TASM code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            c[ad]+r Support    (interpreter support)        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 26 Feb 86:    Modified the "CONS" support to attempt a "short circuit"*
  18. ;*    allocation of a list cell, instead of calling the        *
  19. ;*    "alloc_list_cell" support unconditionally. (JCJ)        *
  20. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  21. ;*                                    *
  22. ;*                    ``In nomine omnipotentii dei''    *
  23. ;************************************************************************
  24. IDEAL
  25. %PAGESIZE    60, 132
  26. MODEL    small
  27. LOCALS    @@
  28.  
  29.     INCLUDE    "scheme.ash"
  30.     INCLUDE "interprt.ash"
  31.  
  32.                     ; load arguments for c?r
  33. MACRO    load_arg
  34.     get2op                ; fetch source/destination register numbers
  35.     save    <si>             ; save the location pointer
  36.     mov    bl, ah             ; copy the source register number
  37.     mov    si, [regs+bx.disp]     ; load contents of the source register
  38.     mov    bl, [regs+bx.bpage]
  39. ENDM
  40.  
  41. DATASEG
  42.  
  43. m_car    DB    "CAR", 0
  44. m_cdr    DB    "CDR", 0
  45. m_caar    DB    "CAAR", 0
  46. m_cadr    DB    "CADR", 0
  47. m_cdar    DB    "CDAR", 0
  48. m_cddr    DB    "CDDR", 0
  49. m_caaar    DB    "CAAAR", 0
  50. m_caadr    DB    "CAADR", 0
  51. m_cadar    DB    "CADAR", 0
  52. m_caddr    DB    "CADDR", 0
  53. m_cdaar    DB    "CDAAR", 0
  54. m_cdadr    DB    "CDADR", 0
  55. m_cddar    DB    "CDDAR", 0
  56. m_cdddr    DB    "CDDDR", 0
  57. m_cadddr DB    "CADDDR", 0
  58.  
  59. m_table    DW    m_car, m_cdr
  60.     DW    m_caar, m_cadr, m_cdar, m_cddr
  61.     DW    m_caaar, m_caadr , m_cadar, m_caddr
  62.     DW    m_cdaar, m_cdadr, m_cddar, m_cdddr
  63.     DW    m_cadddr
  64.  
  65. CODESEG
  66.  
  67. ;************************************************************************
  68. ;* %car                                                 %CAR    DEST    *
  69. ;*                                                                      *
  70. ;* Purpose:  To obtain the first element of a list.  This support is    *
  71. ;*              similar to the usual "car" operation except that %car   *
  72. ;*              returns #!unassigned if one tries to take the car of    *
  73. ;*              nil.                                                    *
  74. ;************************************************************************
  75. PROC    ld_car1
  76.     get1op
  77.     save    <si>
  78.     mov    bx, ax             ; copy operand register number to bx
  79.     mov    si, [regs+bx.disp]     ; load the source operand
  80.     mov    bl, [regs+bx.bpage]
  81.     cmp    [ptype+bx], LISTTYPE
  82.     jne    @@error
  83.     cmp    bl, 0             ; is source operand nil?
  84.     jne    $$endcar
  85. $$undefined:
  86.     mov    bx, ax             ; reload dest register number
  87.     mov    [regs+bx.bpage], UN_PAGE*2 ; set destination reg
  88.     mov    [regs+bx.disp], UN_DISP ;  to #!unassigned
  89.     jmp    next_pc
  90. @@error:
  91. DATASEG
  92. @@msg    DB    "%CAR", 0
  93. CODESEG
  94.     lea    ax, [@@msg]
  95.     jmp    bad_one
  96. ENDP    ld_car1
  97.  
  98. ;************************************************************************
  99. ;* %cdr                                                 %CDR    DEST    *
  100. ;*                                                                      *
  101. ;* Purpose:  To obtain the rest of a list.  This support is similar     *
  102. ;*              to the usual "cdr" operation except that %cdr returns   *
  103. ;*              #!unassigned if one tries to take the cdr of nil.       *
  104. ;************************************************************************
  105. PROC    ld_cdr1
  106.     get1op
  107.     save    <si>
  108.     mov    bx, ax             ; copy operand register number to bx
  109.     mov    si, [regs+bx.disp]     ; load the source operand
  110.     mov    bl, [regs+bx.bpage]
  111.     cmp    bl, 0             ; is source operand nil?
  112.     je    $$undefined
  113.     cmp    [ptype+bx], LISTTYPE
  114.     je    $$endcdr
  115. DATASEG
  116. @@msg    DB    "%CDR", 0
  117. CODESEG
  118.     lea    ax, [@@msg]
  119.     jmp    bad_one
  120. ENDP    ld_cdr1
  121.  
  122. ;************************************************************************
  123. ;*                                                      al   ah         *
  124. ;* Take "car" of a list cell            LD_CAR          dest,src        *
  125. ;************************************************************************
  126. PROC    ld_car
  127.     load_arg
  128. ;    jmp    $$endcar
  129. ENDP
  130. PROC    $$endcar
  131.     cmp    [ptype+bx], LISTTYPE
  132.     jne    bad_car
  133.     ldpage    es, bx
  134.     mov    bl, al             ; copy destination register number
  135.     mov    al, [(LISTDEF es:si).car.page]
  136.     mov    [regs+bx.bpage], al
  137.     mov    ax, [(LISTDEF es:si).car.disp]
  138.     mov    [regs+bx.disp], ax
  139.     jmp    next_pc
  140. ENDP    $$endcar
  141.  
  142. ;************************************************************************
  143. ;*                                                      al   ah         *
  144. ;* Take "cdr" of a list cell            LD_CDR          dest,src        *
  145. ;************************************************************************
  146. PROC    ld_cdr
  147.     load_arg
  148. ;    jmp    $$endcdr
  149. ENDP
  150. PROC    $$endcdr
  151.     cmp    [ptype+bx], LISTTYPE
  152.     jne    bad_cdr
  153.     ldpage    es, bx
  154.     mov    bl, al             ; copy destination register number
  155.     mov    al, [(LISTDEF es:si).cdr.page]
  156.     mov    [regs+bx.bpage], al
  157.     mov    ax, [(LISTDEF es:si).cdr.disp]
  158.     mov    [regs+bx.disp], ax
  159.     jmp    next_pc
  160. ENDP    $$endcdr
  161.  
  162. ;************************************************************************
  163. ;* error handlers                            *
  164. ;************************************************************************
  165. PROC    bad_car                ; attempt to take "car"
  166. ;    jmp    bad_car
  167. ENDP
  168. PROC    bad_cdr                ; attempt to take "cdr" of non-list cell
  169.     mov    si, [save_si]        ; load next instruction's address
  170.     mov    bx, [cb_reg.page]
  171.     ldpage    es, bx
  172.     xor    bx, bx             ; load opcode of failing instruction
  173.     mov    bl, [es:si-3]
  174.     shl    bx, 1
  175.     mov    ax, [m_table+bx-80h]    ; these instructions start at 40h
  176. ;    jmp    bad_one
  177. ENDP
  178. PROC    bad_one
  179.     mov    si, [save_si]        ; load next instruction's address
  180.     mov    bx, [cb_reg.page]
  181.     ldpage    es, bx
  182.     xor    bx, bx
  183.     mov    bl, [es:si-1]         ; load register used as last operand
  184.     add    bx, OFFSET regs
  185.     push    es            ; save es over C call
  186.     mov    cx, 1
  187.     call    set_src_error C, ax, cx, bx
  188.     pop    es
  189.     jmp    sch_err
  190. ENDP    bad_one
  191.  
  192. ;************************************************************************
  193. ;* Simple procedure to put the car, cdr of bl:si in bl:si        *
  194. ;************************************************************************
  195. PROC    $$getcar    NEAR
  196.     cmp    [ptype+bx], LISTTYPE
  197.     jne    bad_car
  198.     ldpage    es, bx
  199.     mov    bl, [(LISTDEF es:si).car.page]
  200.     mov    si, [(LISTDEF es:si).car.disp]
  201.     ret
  202. ENDP
  203.  
  204. PROC    $$getcdr    NEAR
  205.     cmp    [ptype+bx], LISTTYPE
  206.     jne    bad_cdr
  207.     ldpage    es, bx
  208.     mov    bl, [(LISTDEF es:si).cdr.page]
  209.     mov    si, [(LISTDEF es:si).cdr.disp]
  210.     ret
  211. ENDP
  212.  
  213. ;************************************************************************
  214. ;*                                                      al   ah         *
  215. ;* Take "cadddr" of a list cell         LD_CADDDR       dest,src        *
  216. ;************************************************************************
  217. PROC    ld_caddd
  218.     load_arg
  219.     call    $$getcdr
  220.     call    $$getcdr
  221.     call    $$getcdr
  222.     jmp    $$endcar
  223. ENDP
  224.  
  225. ;************************************************************************
  226. ;*                                                      al   ah         *
  227. ;* Take "caar" of a list cell           LD_CAAR         dest,src        *
  228. ;************************************************************************
  229. PROC    ld_caar
  230.     load_arg
  231.     call    $$getcar
  232.     jmp    $$endcar
  233. ENDP
  234.  
  235. ;************************************************************************
  236. ;*                                                      al   ah         *
  237. ;* Take "cadr" of a list cell           LD_CADR         dest,src        *
  238. ;************************************************************************
  239. PROC    ld_cadr
  240.     load_arg
  241.     call    $$getcdr
  242.     jmp    $$endcar
  243. ENDP
  244.  
  245. ;************************************************************************
  246. ;*                                                      al   ah         *
  247. ;* Take "cdar" of a list cell           LD_CDAR         dest,src        *
  248. ;************************************************************************
  249. PROC    ld_cdar
  250.     load_arg
  251.     call    $$getcar
  252.     jmp    $$endcdr
  253. ENDP
  254.  
  255. ;************************************************************************
  256. ;*                                                      al   ah         *
  257. ;* Take "cddr" of a list cell           LD_CDDR         dest,src        *
  258. ;************************************************************************
  259. PROC    ld_cddr
  260.     load_arg
  261.     call    $$getcdr
  262.     jmp    $$endcdr
  263. ENDP
  264.  
  265. ;************************************************************************
  266. ;*                                                      al   ah         *
  267. ;* Take "caaar" of a list cell          LD_CAAAR        dest,src        *
  268. ;************************************************************************
  269. PROC    ld_caaar
  270.     load_arg
  271.     call    $$getcar
  272.     call    $$getcar
  273.     jmp    $$endcar
  274. ENDP
  275.  
  276. ;************************************************************************
  277. ;*                                                      al   ah         *
  278. ;* Take "caadr" of a list cell          LD_CAADR        dest,src        *
  279. ;************************************************************************
  280. PROC    ld_caadr
  281.     load_arg
  282.     call    $$getcdr
  283.     call    $$getcar
  284.     jmp    $$endcar
  285. ENDP
  286.  
  287. ;************************************************************************
  288. ;*                                                      al   ah         *
  289. ;* Take "cadar" of a list cell          LD_CADAR        dest,src        *
  290. ;************************************************************************
  291. PROC    ld_cadar
  292.     load_arg
  293.     call    $$getcar
  294.     call    $$getcdr
  295.     jmp    $$endcar
  296. ENDP
  297.  
  298. ;************************************************************************
  299. ;*                                                      al   ah         *
  300. ;* Take "caddr" of a list cell          LD_CADDR        dest,src        *
  301. ;************************************************************************
  302. PROC    ld_caddr
  303.     load_arg
  304.     call    $$getcdr
  305.     call    $$getcdr
  306.     jmp    $$endcar
  307. ENDP
  308.  
  309. ;************************************************************************
  310. ;*                                                      al   ah         *
  311. ;* Take "cdaar" of a list cell          LD_CDAAR        dest,src        *
  312. ;************************************************************************
  313. PROC    ld_cdaar
  314.     load_arg
  315.     call    $$getcar
  316.     call    $$getcar
  317.     jmp    $$endcdr
  318. ENDP
  319.  
  320. ;************************************************************************
  321. ;*                                                      al   ah         *
  322. ;* Take "cdadr" of a list cell          LD_CDADR        dest,src        *
  323. ;************************************************************************
  324. PROC    ld_cdadr
  325.     load_arg
  326.     call    $$getcdr
  327.     call    $$getcar
  328.     jmp    $$endcdr
  329. ENDP
  330.  
  331. ;************************************************************************
  332. ;*                                                      al   ah         *
  333. ;* Take "cddar" of a list cell          LD_CDDAR        dest,src        *
  334. ;************************************************************************
  335. PROC    ld_cddar
  336.     load_arg
  337.     call    $$getcar
  338.     call    $$getcdr
  339.     jmp    $$endcdr
  340. ENDP
  341.  
  342. ;************************************************************************
  343. ;*                                                      al   ah         *
  344. ;* Take "cdddr" of a list cell          LD_CDDDR        dest,src        *
  345. ;************************************************************************
  346. PROC    ld_cdddr
  347.     load_arg
  348.     call    $$getcdr
  349.     call    $$getcdr
  350.     jmp    $$endcdr
  351. ENDP
  352.  
  353. ;************************************************************************
  354. ;*                 Macro support for set-car!/set-cdr!                  *
  355. ;************************************************************************
  356. MACRO    set_cc    field
  357.     LOCAL    @@error
  358.     get2op
  359.     save    <si>
  360.     mov    bl, al
  361.     mov    di, [regs+bx.page]     ; load dest register page number
  362.     or    di, di            ; are we trying to set car/cdr of nil?
  363.     jz    @@error
  364.     cmp    [ptype+di], LISTTYPE
  365.     jne    @@error
  366.     ldpage    es, di
  367.     mov    di, [regs+bx.disp]     ; Load destination displacement
  368.     mov    bl, ah             ; Copy src register number
  369.     mov    al, [regs+bx.bpage]    ; redefine field's page number
  370.     mov    [(LISTDEF es:di).field.page], al
  371.     mov    ax, [regs+bx.disp]     ; redefine field's displacement
  372.     mov    [(LISTDEF es:di).field.disp], ax
  373.     jmp    next_pc
  374. @@error:
  375. ENDM
  376.  
  377. ;************************************************************************
  378. ;*                                                          al   ah     *
  379. ;* Side effect car field  (set-car! dest src)   SET-CAR!    dest,src    *
  380. ;*                                                                      *
  381. ;* Purpose:  Interpreter support for the set-car! operation.            *
  382. ;************************************************************************
  383. PROC    set_car
  384.     set_cc    car
  385. DATASEG
  386. @@msg    DB    "SET-CAR!", 0
  387. CODESEG
  388.     lea    bx, [@@msg]
  389. bad_set_car:
  390.     mov    ax, [cb_reg.page]
  391.     ldpage    es, ax
  392. $$set_error:
  393.     xor    ax, ax
  394.     mov    al, [es:si-1]
  395.     add    ax, OFFSET regs
  396.     push    ax
  397.     xor    ax, ax
  398.     mov    al, [es:si-2]
  399.     add    ax, OFFSET regs
  400.     mov    cx, 2
  401.     call    set_src_error C, bx, cx, ax
  402.     restore <si>
  403.     jmp    sch_err
  404. ENDP
  405.  
  406. ;************************************************************************
  407. ;*                                                          al   ah     *
  408. ;* Side effect cdr field  (set-cdr! dest src)   SET-CDR!    dest,src    *
  409. ;*                                                                      *
  410. ;* Purpose:  Interpreter support for the set-cdr! operation.            *
  411. ;************************************************************************
  412. PROC    set_cdr
  413.     set_cc    cdr
  414. DATASEG
  415. @@msg    DB    "SET-CDR!", 0
  416. CODESEG
  417.     lea    bx, [@@msg]
  418.     jmp    bad_set_car
  419. ENDP
  420.  
  421. ;************************************************************************
  422. ;*                                                      dl   dh  al     *
  423. ;* Cons - Create and define new list cell       CONS    dest,car,cdr    *
  424. ;*                                                                      *
  425. ;* Purpose:  Interpreter support for the Scheme "cons" operation.       *
  426. ;************************************************************************
  427. PROC    s_cons
  428.     get2op
  429.     mov    dx, ax
  430.     xor    ax, ax
  431.     get1op                ; load cdr register number
  432.     save    <si>
  433.                     ; Attempt a "short circuit" list cell allocation
  434.     mov    di, [listpage]
  435.     shl    di, 1
  436.     mov    si, [nextcell+di]
  437.     cmp    si, END_LIST
  438.     je    @@outofspace
  439.     ldpage    es, di
  440.     mov    cx, [(LISTDEF es:si).car.disp]
  441.     mov    [nextcell+di], cx
  442. @@resume:                ; Move contents of CDR register to CDR field of new list cell
  443.     mov    bx, ax             ; copy register number to bx
  444.     mov    al, [regs+bx.bpage]
  445.     mov    [(LISTDEF es:si).cdr.page], al
  446.     mov    ax, [regs+bx.disp]
  447.     mov    [(LISTDEF es:si).cdr.disp], ax
  448.     mov    bl, dh            ; Move contents of CAR register to CAR field of new list cell
  449.     mov    al, [regs+bx.bpage]
  450.     mov    [(LISTDEF es:si).car.page], al
  451.     mov    ax, [regs+bx.disp]
  452.     mov    [(LISTDEF es:si).car.disp], ax
  453.     mov    bl, dl            ; Update destination register number with pointer to new list cell
  454.     mov    [regs+bx.page], di
  455.     mov    [regs+bx.disp], si
  456.     jmp    next_pc
  457.  
  458. @@outofspace:
  459.     push    ax dx es
  460.     call    alloc_list_cell C, [tmp_adr]
  461.     pop    es dx ax
  462.     mov    di, [tmp_reg.page]
  463.     mov    si, [tmp_reg.disp]
  464.     ldpage    es, di
  465.     jmp    @@resume
  466. ENDP    s_cons
  467.  
  468. ;************************************************************************
  469. ;* List - Create and define new list cell w/ nil cdr    LIST    dest    *
  470. ;*                                                                      *
  471. ;* Purpose:  Interpreter support for the Scheme "list" operation.       *
  472. ;************************************************************************
  473. PROC    s_list
  474.     get1op
  475.     lea    bx, [tmp_reg]
  476.     save    <si>
  477.     push    ax            ; save register pointer
  478.     call    alloc_list_cell C, bx
  479.     pop    si             ; restore destination register pointer
  480.     mov    bx, [tmp_reg.page]
  481.     ldpage    es, bx
  482.     mov    di, [tmp_reg.disp]
  483.     mov    ax, di
  484.     xchg    ax, [regs+si.disp]
  485.     xchg    bl, [regs+si.bpage]    ; put our new pointer, reading the car
  486.     mov    [(LISTDEF es:di).car.disp], ax
  487.     mov    [(LISTDEF es:di).car.page], bl
  488.     xor    ax, ax            ; create nil cdr field
  489.     mov    [(LISTDEF es:di).cdr.disp], ax
  490.     mov    [(LISTDEF es:di).cdr.page], al
  491.     jmp    next_pc
  492. ENDP    s_list
  493.  
  494. ;************************************************************************
  495. ;*                                                      al   ah         *
  496. ;* (list a b)                                   LIST2   dest,src        *
  497. ;*                                                                      *
  498. ;* Purpose:  Interpreter support for the (list a b) operation.          *
  499. ;*                                                                      *
  500. ;* Description:  This operation:     (list a b)                         *
  501. ;*               is equivalent to:   (cons a (cons b nil))              *
  502. ;************************************************************************
  503. PROC    list2
  504.     get2op
  505.     save    <si>
  506.     mov    bl, al             ; save the destination register number
  507.     push    bx
  508.     mov    bl, ah             ; copy the source register number
  509.     add    bx, OFFSET regs
  510.     lea    ax, [nil_reg]
  511.     lea    cx, [tmp_reg]
  512.     push    cx            ; save it for later use
  513.     call    cons C, cx, bx, ax     ; (cons tmp_reg src nil_reg)
  514.     pop    cx bx            ; restore tmp_reg address
  515.     add    bx, OFFSET regs
  516.     call    cons C, bx, bx, cx    ; (cons dest dest tmp_reg)
  517.     jmp    next_pc
  518. ENDP    list2
  519.  
  520. ;************************************************************************
  521. ;* (append! list obj)                                append!  dest  src *
  522. ;*                                                                      *
  523. ;* Purpose:  Scheme interpreter support for the append! primitive       *
  524. ;************************************************************************
  525. PROC    appendb
  526.     get2op
  527.     save    <si>
  528.     mov    bl, al
  529.     lea    di, [regs+bx]
  530.     mov    bx, [(REG di).page] ; load list header from dest reg
  531.     cmp    [ptype+bx], LISTTYPE
  532.     jne    @@error
  533.     cmp    bl, NIL_PAGE*2         ; is arg1 == nil?
  534.     jne    @@findend
  535.     mov    bl, ah             ; get 2nd arg & return it in dest reg
  536.     lea    si, [regs+bx]         ; si=address of src reg
  537.     mov    bx, [(REG si).page] ; return source
  538.     mov    [(REG di).page], bx
  539.     mov    bx, [(REG si).disp]
  540.     mov    [(REG di).disp], bx
  541.     jmp    next_pc
  542.  
  543. @@findend:
  544.     mov    di, [(REG di).disp]
  545. @@nextcell:
  546.     ldpage    es, bx
  547.     mov    bl, [(LISTDEF es:di).cdr.page]
  548.     cmp    bl, NIL_PAGE*2         ; CDR == nil?
  549.     je    @@endoflist
  550.     cmp    [ptype+bx], LISTTYPE    ; still pointing to cons nodes?
  551.     jne    @@endoflist
  552.     mov    di, [(LISTDEF es:di).cdr.disp]
  553.     cmp    [s_break], 0
  554.     je    @@nextcell
  555.     mov    ax, 3
  556.     call    restart C, ax        ; link to Scheme debugger
  557.  
  558. @@endoflist:
  559.     mov    bl, ah             ; else get 2nd arg & return it in dest reg
  560.     lea    si, [regs+bx]         ; si=address of src reg
  561.     mov    bx, [(REG si).page]
  562.     mov    [(LISTDEF es:di).cdr.page], bl
  563.     mov    bx, [(REG si).disp]
  564.     mov    [(LISTDEF es:di).cdr.disp], bx
  565.     jmp    next_pc
  566.  
  567. @@error:
  568. DATASEG
  569. @@msg    DB    "APPEND!", 0
  570. CODESEG
  571.     lea    bx, [@@msg]
  572.     jmp    $$set_error
  573. ENDP    appendb
  574.  
  575. ;************************************************************************
  576. ;* (list_tail list count)                       l_tail list(dest) count *
  577. ;*                                                                      *
  578. ;* Purpose:  Scheme interpreter support for the list_tail primitive     *
  579. ;************************************************************************
  580. PROC    l_tail
  581.     get2op
  582.     save    <si>
  583.  
  584.     xor    bh, bh
  585.     mov    bl, al
  586.     lea    si, [regs+bx]        ; saves reg in si for later
  587.  
  588.     xor    bh, bh
  589.     mov    bl, ah
  590.     add    bx, OFFSET regs     ; get register containing count
  591.     call    int2long C, bx
  592.     or    dx, dx
  593.     js    @@error
  594.     mov    cx, ax            ; count is in cx:dx
  595.  
  596.     mov    bx, [(REG si).page]
  597.     cmp    [ptype+bx], LISTTYPE
  598.     jne    @@error
  599.  
  600.     mov    ax, bx             ; ax <= page of list
  601.     mov    bx, [(REG si).disp]    ; bx <= disp of list
  602. @@loop:
  603.     mov    di, cx            ; get a copy of counter
  604.     or    di, dx            ; jump if counter is 0
  605.     jz    @@ret
  606.     cmp    ax, NIL_PAGE * 2    ; end of list?
  607.     je    @@ret
  608.     ldpage    es, ax
  609.     mov    al, [(LISTDEF es:bx).cdr.page]
  610.     mov    bx, [(LISTDEF es:bx).cdr.disp]
  611.     sub    cx, 1             ; decrement count
  612.     sbb    dx, 0
  613.     jmp    @@loop
  614.  
  615. @@ret:
  616.     mov    [(REG si).bpage], al    ; save page in reg
  617.     mov    [(REG si).disp], bx    ; save disp in reg
  618. @@exit:
  619.     jmp    next_pc
  620.  
  621. @@error:
  622.     restore <si>
  623.     xor    ax, ax
  624.     mov    al, [es:si-1]
  625.     add    ax, OFFSET regs     ; get last operand
  626.     push    ax             ;   and push for call
  627.     xor    ax, ax
  628.     mov    al, [es:si-2]
  629.     add    ax, OFFSET regs     ; get first operand
  630.     push    ax             ;   and push for call
  631. DATASEG
  632. @@msg    DB    "LIST_TAIL", 0
  633. CODESEG
  634.     lea    bx, [@@msg]
  635.     mov    ax, 2
  636.     call    set_src_error C, bx, ax
  637.     jmp    sch_err
  638. ENDP    l_tail
  639.  
  640.     END
  641.